Attribute VB_Name = "Generic_macros"
Option Base 1
Public calculation_state As Single
Public max_row As Single
Public max_col As Single

Public data_to_save(1000) as single
public col_start
public col_end
public row_selected 


Public Sub Auto_Open()
'
'  Make a menu with an add-in
'
    Dim MyButton As CommandBarPopup        'This is the Main Menu Button for Print
    Dim Contents As CommandBarPopup        'This is the Main Menu Button for Print
    Dim Sheet_Colour_Link As CommandBarPopup        'This is the Main Menu Button for Print
    Dim List_Functions As CommandBarPopup        'This is the Main Menu Button for Print
           
           
    Application.ScreenUpdating = False
    
'
' When set to mannual will not recalculate on save
'
    Application.CalculateBeforeSave = False

'
'  Re-set the menu bar before adding
'
    CommandBars("Worksheet Menu Bar").Reset
'
'  Set the manin menu button at the top
'  The & puts an underline and allows use of the ALT key
'
    Set MyButton = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
        MyButton.Caption = "&Added Short Cuts"
    Set Contents = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
        Contents.Caption = "&Table of Contents"
    Set Sheet_Colour_Link = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
        Sheet_Colour_Link.Caption = "&Colour Cells from Sheet Tab Colour"
    Set List_Functions = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
        List_Functions.Caption = "&List Functions"

'
' Assign Short-cut keys
'
    Application.OnKey "^R", "x_fill_right"
    Application.OnKey "^Z", "x_undo_fill_right"

    Application.OnKey "^G", "x_gridlineOff"
    Application.OnKey "^C", "x_Colour"
    Application.OnKey "^T", "x_TrueSwitch"
    Application.OnKey "^F", "x_FalseSwitch"
    Application.OnKey "^P", "x_Decimals"

    Application.OnKey "^Q", "x_ColourTitles"

    Application.OnKey "^D", "x_delete_rows"
    Application.OnKey "^E", "x_delete_cols"

    Application.OnKey "^M", "x_comma1"
    Application.OnKey "^N", "x_comma2"

    Application.OnKey "%-", "x_product"
    
    Application.OnKey "^S", "x_save_without_calc"
        
    Application.OnKey "^S", "x_save_without_calc"


'
'  The last item is the macro that is called
'
        Call MakeButton(MyButton, "Automatic Copy to Right (SHIFT, CNTL, R)", "x_fill_right")
        Call MakeButton(MyButton, "Undo Fill to Right (SHIFT, CNTL, Z)", "x_undo_fill_right")
        Call MakeButton(MyButton, "Automatic Copy to Right (SHIFT, CNTL, R)", "x_fill_right")
        Call MakeButton(MyButton, "Product of Above Rows (ALT, -)", "x_fill_right")
        Call MakeButton(MyButton, "Colour Inputs (SHIFT,CNTL,C) ", "x_Colour")
        Call MakeButton(MyButton, "Percent with Decimals (SHIFT, CNTL, P) ", "x_Decimals")
        Call MakeButton(MyButton, "True Switch (SHIFT, CNTL, T) ", "x_TrueSwitch")
        Call MakeButton(MyButton, "False Switch (SHIFT, CNTL, F)", "x_FalseSwitch")
        Call MakeButton(MyButton, "Fix Auto Percent (SHIFT, CNTL, X)", "x_Fix_Decimal")
        Call MakeButton(MyButton, "Comma Format 1 (SHIFT, CNTL, M)", "x_comma1")
        Call MakeButton(MyButton, "Comma Format 2 (SHIFT, CNTL, N)", "x_comma2")
        Call MakeButton(MyButton, "Delete Blank Rows (SHIFT, CNTL, D)", "x_delete_rows")
        Call MakeButton(MyButton, "Delete Blank Columns (SHIFT, CNTL, E)", "x_delete_cols")
        Call MakeButton(MyButton, "Hide Comments (SHIFT, CNTL, Q)", "x_hide_comment")
        Call MakeButton(MyButton, "Grid Lines OFF (SHIFT, CNTL, G)", "x_grielineOff")
                
        Call MakeButton(Contents, "Run Table of Contents Macro", "x_Create_Table_of_Contents_From_Sheet_Names")
    
        Call MakeButton(Sheet_Colour_Link, "Colour Cells Linked to Other Sheets from Tab Colour of Sheet", "x_Create_Linked_Tab_Colour_ALL_SHEETS")

        Call MakeButton(List_Functions, "List User Created Function in Generic Macros", "x_list_functions")

        calculation_state = Application.Calculation
        
Sheets(1).Select
    
End Sub


Sub MakeButton(mnuName As Object, strCap As String, strOnA As String)
Dim MyButton As CommandBarButton

Set MyButton = mnuName.Controls.Add(msoControlButton)
    MyButton.Style = msoButtonCaption
    MyButton.Caption = strCap
    MyButton.OnAction = strOnA

End Sub
Sub auto_close()
'
'   Auto runs when Workbook is close.
'
      
    On Error Resume Next
    CommandBars("Worksheet Menu Bar").Reset
    x_recalc


End Sub

sub x_basic_save
	ActiveWorkbook.Save
end sub

Sub x_fill_right()

Application.screenupdating = False

    last_col = 16000                             ' works with 2007 and later
    
    row_num = Selection.Rows.Count               ' find the size of the range to copy
    col = Selection.Columns.Count

     cell_start = Selection.Cells(1, 1)            ' define the title
    
    org_col = Selection.Cells(1, 1).column         ' get the starting point
    org_row = Selection.Cells(1, 1).row
             
    up_move = 1                                    ' how many rows to move up
    
copy_process:
    
' find the base for copying

    On Error GoTo exit1                            ' doesnt work on first row
    Cells(org_row - up_move, org_col).Select       ' go up by the up_move
    
    Selection.End(xlToRight).Select                ' see how many to move up
    
    end_col = ActiveCell.column                    ' find th end col
    end_row = ActiveCell.row
    
'    MsgBox end_row & "   " & end_col
'    MsgBox end_row + 1 & "   " & org_col
        
' check if have to go up further
        
    If end_col > last_col Then                       ' if a blank row then go up and try again
        up_move = up_move + 1
        If org_row - up_move > 1 Then GoTo copy_process  ' cannot work when get to the top
    End If
        
    For row = org_row To org_row + row_num - 1              ' this is like CNTL R

        if end_col > 14000 then msgbox " WARNING, COPYING MORE THAN 14,000 COLUMNS "
        
        Range(Cells(row, org_col), Cells(row, end_col)).Select  ' select the appropriate area
        Selection.FillRight                                     '  CNTL R

'  This is for the undo stuff

'

    Next row

        for i = org_col to  end_col - org_col + 1
            data_to_save(i) = cells(row,org_col)
        next i

        col_start = org_col
        col_end   = end_col
        row_selected = row

    Cells(org_row, org_col).Activate                       ' go back to original cell

exit1:
End Sub

Sub x_undo_fill_right()

Application.screenupdating = False

    last_col = 16000                             ' works with 2007 and later

        for i = col_start to  col_end - col_start + 1
            cells(row_selected,org_col) = data_to_save(i) 
        next i

end sub   



Sub x_product()
'
    ActiveCell.FormulaR1C1 = "=PRODUCT(R[-2]C:R[-1]C)"
    x_fill_right
End Sub


Sub x_Delete_rows()
'
Count = 0                       ' count rows
For row = 1 To 400
  If WorksheetFunction.IsNumber(Cells(row, 1)) = True Or WorksheetFunction.IsText(Cells(row, 1)) = True Then
     Count = Count + 1
  End If
Next row
  

For delete_row = Count To 1 Step -1
    keep_row = 0
    Cells(delete_row, 1).Select
    For col = 1 To 20
         If WorksheetFunction.IsNumber(Cells(delete_row, col)) = True Then
'         Or WorksheetFunction.IsText(Cells(delete_row, col)) = True Then
              keep_row = 1
         End If
    Next col
    
   If keep_row = 0 Then
         Selection.EntireRow.Delete
   End If

Next delete_row
   
End Sub

Sub x_Delete_cols()
'
Count = 20

begin_row = InputBox(" Enter the Begining Row Number After which to Test ")

For delete_col = Count To 1 Step -1
    keep_col = 0
    Cells(1, delete_col).Select
    For row = begin_row To 20
         If WorksheetFunction.IsNumber(Cells(row, delete_col)) = True Then
'         Or WorksheetFunction.IsText(Cells(delete_row, col)) = True Then
              keep_col = 1
         End If
    Next row
    
   If keep_col = 0 Then
         Selection.EntireColumn.Delete
   End If

Next delete_col
   
End Sub

Sub x_comma1()
'
' comma1 Macro
'
    Selection.Style = "Comma"
    Selection.NumberFormat = _
        "_-* #,##0.0 __-;-* #,##0.0 __-;_-* ""-""?? __-;_-@_-"
    Selection.NumberFormat = "_-* #,##0 __-;-* #,##0 __-;_-* ""-""?? __-;_-@_-"
End Sub


Sub x_comma2()
'
' comma2 Macro
'
    Selection.NumberFormat = "#,##0"
End Sub

Sub x_show_comment()
'
' comments Macro
'
' Keyboard Shortcut: Ctrl+Shift+M
'
    Application.DisplayCommentIndicator = xlCommentAndIndicator
End Sub


Sub x_hide_comment()
'
' commnet2 Macro
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub

Sub x_miscellaneous_functions()

End Sub

Sub x_list_functions()

MsgBox "Function for Interpolating Numbers ................... interpolate()  " & Chr(13) & _
       "Function for Lookup with Interpolate.................. lookup_interpolate()   " & Chr(13) & _
       "Function for Lookup with NA .......................... lookup_NA()    " & Chr(13) & _
       "Function for Combining Text .......................... sum_labels()    " & Chr(13) & _
       "Function for Sheet Name .............................. sheet_name()    " & Chr(13) & _
       "Function for Dispalying Formulas...................... show_formula()   "

End Sub



Function show_form(cell)
    show_form = cell.Formula
End Function
Function show_formula(cell)
    show_formula = "< ---- Formula for: " & cell.Address & "  " & cell.Formula
End Function
Function show_formulaR(cell)
    show_formulaR = "< ---- " & cell.Formula
End Function
Function show_formulaL(cell)
    show_formulaL = cell.Formula & "----> "
End Function


Function sheet_name(cell)
    sheet_name = cell.Parent.Name
End Function

Function sum_labels(series)
    num = series.Count
    For i = 1 To num
        sum_labels = sum_labels & series(i)
    Next i
End Function


Function lookup_NA(lookup_value, test_array, result_array)

found = 0

For i = 1 To test_array.Count
    If WorksheetFunction.IsNumber(test_array(i)) Then
        If lookup_value >= test_array(i) Then
            found = 1
            Exit For
        End If
    End If
Next i

If found = 1 Then
  lookup_NA = WorksheetFunction.Lookup(lookup_value, test_array, result_array)
Else
    lookup1 = 0
End If

End Function

Function match_adj(lookup_value, lookup_array)

exact_match = 0
found = 0
num = lookup_array.Count
If num > 2000 Then num = 2000

For i = 1 To num
    If lookup_value = lookup_array(i) Then
        found = 1
        Exit For
    End If
Next i

exact_match1 = i

If found = 1 Then exact_match = WorksheetFunction.Match(lookup_value, lookup_array, 0)

' MsgBox " exact match " & exact_match & " exact match 1 " & exact_match1

aprox_match = WorksheetFunction.Match(lookup_value, lookup_array) + 1

If exact_match <> 0 Then used_match = exact_match
If exact_match = 0 Then used_match = aprox_match

match_adj = WorksheetFunction.Min(used_match, num)

End Function

Function lookup_interpolate(lookup_value, lookup_vector, result_vector)

 num_cols = lookup_vector.Columns.Count
 num_rows = lookup_vector.Rows.Count
 num = lookup_vector.Count
 Count = 0
 
 For j = 1 To 500
   If WorksheetFunction.IsNumber(lookup_vector(j)) = True Then
      Count = Count + 1
   End If
 Next j
   
 num = Count


If num_cols > 1 Then vector_type = "cols"
If num_rows > 1 Then vector_type = "rows"

found = 0
For i = 1 To lookup_vector.Count
    If WorksheetFunction.IsNumber(lookup_vector(i)) Then
        If lookup_value >= lookup_vector(i) Then
            found = 1
            Exit For
        End If
    End If
Next i

If found = 1 Then
   match_start_lookup = WorksheetFunction.Match(lookup_value, lookup_vector)
Else
   lookup_interpolate = 0
   Exit Function
End If

start_lookup = WorksheetFunction.Index(lookup_vector, match_start_lookup)

 If match_start_lookup < num Then
    end_lookup = WorksheetFunction.Index(lookup_vector, match_start_lookup + 1)
 Else                                                                              ' last part
   end_lookup = WorksheetFunction.Index(lookup_vector, match_start_lookup)
  lookup_interpolate = WorksheetFunction.Lookup(end_lookup, lookup_vector, result_vector)
   Exit Function
 End If

difference = end_lookup - start_lookup

Abs1 = Abs(lookup_value - start_lookup)
Abs2 = Abs(lookup_value - end_lookup)

' MsgBox " difference " & difference & " end_lookup " & end_lookup & " num " & num

If difference <> 0 Then
    Weight1 = (difference - Abs1) / difference
    Weight2 = (difference - Abs2) / difference
End If

result1 = WorksheetFunction.Lookup(start_lookup, lookup_vector, result_vector)
result2 = WorksheetFunction.Lookup(end_lookup, lookup_vector, result_vector)

lookup_interpolate = result1 * Weight1 + result2 * Weight2

End Function


Function interpolate(series) As Variant

num = series.Count
ReDim Forward(num) As Single
ReDim Backward(num) As Single
ReDim interp(num) As Boolean
ReDim periods(num) As Single
ReDim grth(num) As Single
ReDim adj_val(num) As Single


    For i = 1 To num
       For j = i To num
            If series(j) > 0 Then
                Forward(i) = series(j)
                Exit For
            End If
        Next j
    Next i
      
    For i = 1 To num
       For j = i To 1 Step -1
            If series(j) > 0 Then
                Backward(i) = series(j)
                Exit For
            End If
        Next j
    Next i
      
    For i = 1 To num
        interp(i) = False
      If series(i) = 0 Or WorksheetFunction.IsNumber(series(i)) = False Then
        interp(i) = True
        Count = Count + 1
        periods(i) = Count
      Else
        periods(i) = Count
        Count = 0
      End If
    Next i
      
    For i = 2 To num
      If series(i) <> 0 Then
        growth_ = (series(i) / Backward(i - 1)) ^ (1 / (periods(i) + 1)) - 1
'        growth_ = (series(i) / Backward(i - 1))
                                                              
        For j = i - 1 To 1 Step -1
           If interp(j) = True Then
             grth(j) = growth_
           Else
              Exit For
           End If
        Next j
      End If
    Next i
      
    For i = 1 To num
        adj_val(i) = series(i)
      
      If interp(i) = True Then
        adj_val(i) = adj_val(i - 1) * (1 + grth(i))
      End If
    Next i
      
interpolate = adj_val

End Function




Function payback(series)

Dim counter As Single

Dim num As Single                                       ' number in series
num = Application.CountA(series)                        ' count the number in series
 ReDim cum_series(num) As Single
 
' dimesion of cumulative cash

counter = 0
For i = 1 To num                                        ' loop around cash flows
    
    If (series(i) > 0) Then counter = counter + 1       ' count if the cash is positive
    If (i > 1) Then
        cum_series(i) = cum_series(i - 1) + series(i)   ' cumulative cash flow
    End If
    If (i = 1) Then cum_series(i) = series(i)           ' cumulative cash flow
    If (cum_series(i) > 0) Then                         ' test when turns to positive
        GoTo finished:
    End If
Next i
i = num

finished:                                               ' compute payback
If ((cum_series(i) - cum_series(i - 1) <> 0)) Then
    factor = -cum_series(i - 1) / (cum_series(i) - cum_series(i - 1))
Else
    factor = 0
End If
If (i < num) Then
    payback = factor + counter - 1
Else
    payback = num + 1
End If


End Function


Function dpayback(d_rate, series)

' Dim series As Variant
Dim num As Single
num = Application.CountA(series)
ReDim cum_series(num)
ReDim dfactor(num)

counter = 0

For i = 1 To num

If (series(i) > 0) Then counter = counter + 1
 
 dfactor(i) = 1 / ((1 + d_rate) ^ counter)

If (i > 1) Then
    cum_series(i) = cum_series(i - 1) + series(i) * dfactor(i)
End If

If (i = 1) Then cum_series(i) = series(i)

If (cum_series(i) > 0) Then
  GoTo finished:
End If

Next i

i = num

finished:
  
If ((cum_series(i) - cum_series(i - 1)) <> 0) Then
    factor = -cum_series(i - 1) / (cum_series(i) - cum_series(i - 1))
Else
    factor = 0
End If

If (i < num) Then
    dpayback = counter + factor - 1
Else
    dpayback = num + 1
End If

End Function


Sub x_Colour()
'
' Colour Macro
'
    Cells.Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.SpecialCells(xlCellTypeConstants, 21).Select
    With Selection.Font
        .Color = -3394765
        .TintAndShade = 0
    End With
End Sub

Sub x_Decimals()
'
' Decimals Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
    Selection.NumberFormat = "0.0%"
    Selection.NumberFormat = "0.00%"
End Sub

Sub x_TrueSwitch()
'
' TrueSwitch Macro
'
' Keyboard Shortcut: Ctrl+Shift+T
'
    Selection.FormatConditions.Add Type:=xlTextString, String:="T", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -3394765
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Sub x_FalseSwitch()
'
' FalseSwitch Macro
'
' Keyboard Shortcut: Ctrl+Shift+F
'
    Selection.FormatConditions.Add Type:=xlTextString, String:="F", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Sub x_fix_decimal()
 ActiveCell = ActiveCell * 100
 Selection.NumberFormat = "#,##0.00"
End Sub

Sub x_colourTitles()
'
' colourTitles Macro
'
For row = 1 To 1000

If WorksheetFunction.IsNonText(Cells(row, 1)) = False Then
    
    row_range = row & ":" & row
    
    Rows(row_range).Select
    With Selection.Font
        .Color = -3394765
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13382451
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True

End If
Next row

End Sub

Sub x_find_rows()
  end_row = 1000
  start_row = 1
  start_col = 1
  max_row = 0
  same_row = 0

For col = start_col To 15
  
  For row = start To end_row
    last_max = max_row
    If row Mod 10 = 0 Then
'    MsgBox " col " & col & " row " & row & "  max_row " & max_row & " start row " & start_row
    End If
       
       On Error Resume Next
       If WorksheetFunction.IsText(Cells(row, col)) = True Or WorksheetFunction.IsNumber(Cells(row, col)) = True Then
           If row > max_row Then max_row = row
       End If
  Next row
  
  start = max_row
  If max_row > 0 Then end_row = max_row + 15
  If max_row = last_max Then same_row = same_row + 1
  If same_row > 10 Then
'    MsgBox max_row
    Exit Sub
  End If

Next col

End Sub
Sub x_find_cols()
  end_col = 300
  start_row = 1
  start_col = 1
  max_col = 0
  same_col = 0

  For row = start_row To 100
  
    For col = start_col To end_col
    last_col = max_col
    If col Mod 10 = 0 Then
'     MsgBox " col " & col & " row " & row & "  max_row " & max_col & " start col " & start_col
    End If
       
       On Error Resume Next
       If WorksheetFunction.IsText(Cells(row, col)) = True Or WorksheetFunction.IsNumber(Cells(row, col)) = True Then
           If col > max_col Then max_col = col
       End If
  Next col
  start_col = max_col
  If max_col > 0 Then end_col = max_col + 100
  If max_col = last_col Then same_col = same_col + 1
  If same_col > 10 Then Exit Sub
  
Next row

End Sub


Sub x_Create_Table_of_Contents_From_Sheet_Names()
'
Dim sht_name(500)

Dim sheet_name As String, num, i As Single
Dim range_name, range_name1, range_name2, range_name3, range_name4, range_name5, range_name6 As String
Dim row_num, row_num_, col_num As Single
Dim sub_address As String
Dim test As Single

'
'    With Application
'        .Calculation = xlSemiautomatic
'        .MaxChange = 0.001
'    End With
'    ActiveWorkbook.PrecisionAsDisplayed = False

org_calc_state = Application.Calculation 

Application.Calculation = xlCalculationManual


test1 = MsgBox("Make Sure this is a blank sheet, if not press cancel ", vbOKCancel)

If test1 = 2 Then Exit Sub



sheet_name = ActiveSheet.Name                                ' Keep sheet name for so can go back at the end

test = 2

' determine the total number of sheets

num = Sheets.Count


' starting with the first sheet, then go through each sheet and get each name

Sheets(1).Select
For i = 1 To Sheets.Count

   On Error Resume Next                                       ' need this error check for the graph sheets
   
   Sheets(i).Select
   
' Gets the name and puts in array sht_name

   sht_name(i) = ActiveSheet.Name                             ' save the sheet name in an array for display

    If (i < num) Then ActiveSheet.Next.Select
Next i

' Go back to contents sheet

Sheets(sheet_name).Select

  range_name = "A1"

If range_name = "" Then Exit Sub

Range(range_name).Select                                 ' Put each sheet to A1 range
row_num = ActiveCell.row
col_num = ActiveCell.column
 
' Print out list of sheet names
 
For i = 1 To num
    row_num_ = row_num + i
    Cells(row_num_, col_num).Select
    Selection = sht_name(i)
 '    MsgBox (sht_name(i))
Next i

' Make a hyperlink for each sheet

For i = 1 To num
    row_num_ = row_num + i
    Cells(row_num_, col_num + 1).Select
    Selection = sht_name(i)
 
    sub_address = "'" & sht_name(i) & "'!A1"

    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        sub_address
        
    Cells(row_num_, col_num).Select

    Selection = i

Next i

' define range name for putting file name, last saved etc.

range_name1 = range_name & ":D" & i
range_name2 = "A" & i + 2
range_name3 = "C" & i + 2
range_name4 = "A" & i + 7
range_name5 = "A" & i + 4
range_name6 = "C" & i + 4
range_name7 = "A" & i + 5
range_name8 = "C" & i + 5

'
'  This is where the hyperlinks are put into each sheet
'
 If test = 2 Then GoTo Fmt:
 
 If test <> 2 Then Run "Put_Sheet_Names_in_A1"                          ' Be careful with this
 
Fmt:
'
    Columns("B:B").Select
    Selection.Columns.AutoFit
    Columns("C:C").Select
    Selection.ColumnWidth = 33
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Sheet Tab"
    Range("B1").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
' Insert description in second column
    
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("C1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Cells.Select
    ActiveWindow.SmallScroll ToRight:=3
    Cells.Select
    ActiveWindow.SmallScroll ToRight:=3
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
   
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Author"
    Range("D1").Select

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
          
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Selection.Font.Bold = True
    Cells.Select
    ActiveWindow.SmallScroll ToRight:=3
    Cells.Select
    ActiveWindow.SmallScroll ToRight:=3
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    
     Range(range_name1).Select
    
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 
  Range(range_name2).Select
    ActiveCell.FormulaR1C1 = " File Name: "
    Range(range_name3).Select
    ActiveCell.FormulaR1C1 = "=File_name()"
            
  Range(range_name5).Select
    ActiveCell.FormulaR1C1 = " Last Save Date "
    Range(range_name6).Select
    ActiveCell.FormulaR1C1 = "=lastsaved1()"
     
  Range(range_name7).Select
    ActiveCell.FormulaR1C1 = " Last Save By"
    Range(range_name8).Select
    ActiveCell.FormulaR1C1 = "=lastsaveby1()"

  Range(range_name4).Select
    ActiveCell.FormulaR1C1 = " Colour Codes "
 
  Range("A1").Select
  
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    
    Selection.EntireColumn.Insert

End Sub
Sub x_last_saved_functions()

Application.Calculation = org_calc_state

End Sub

Function File_name() As Variant
Application.Volatile
File_name = ActiveWorkbook.FullName
End Function

Function MyUDF(lastsaved1 As Boolean) As Double
   ' Good practice to call this on the first line.
   Application.Volatile (lastsaved1)
   MyUDF = Now
End Function

Function Last_save_by() As Variant
Application.Volatile
Last_save_by = ActiveWorkbook.BuiltinDocumentProperties(7)
End Function

Function LastSaved() As String
Application.Volatile (True)
LastSaved = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
Selection.NumberFormat = "dd-mmmm-yyyy hh:mm"
Selection.HorizontalAlignment = xlLeft
End Function

Function Lastsaveby1() As Variant
        Application.Volatile True
        Lastsaveby1 = ActiveWorkbook.BuiltinDocumentProperties(7)
End Function

Function LastSaved1() As String
        Application.Volatile True
        LastSaved1 = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
        Selection.NumberFormat = "dd-mmmm-yyyy hh:mm"
        Selection.HorizontalAlignment = xlLeft
End Function
Sub x_recalc()
    Application.CalculateFull
End Sub
Sub x_save_without_calc()

org_calc_state = Application.Calculation

Application.Calculation = xlCalculationManual
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
x_recalc
Application.Calculation = org_calc_state
End Sub

Sub x_gridlineOff()
'Raccouris: Ctrl G

ActiveWindow.DisplayGridlines = False

End Sub


Sub x_Create_Linked_Tab_Colour_ALL_SHEETS()

'
' SpreadsheetColors Macro
' UserForm1.Show
 
Dim sheet_color(1000) As Variant, sheets_name(1000) As Variant
      
Dim first_quote As Single, test As Variant, background As Variant, current_sheet As String, this_sheet As Single, num_sheets As Single, total_sheets As Single
Dim single_sheet As Single, start_num As Single, end_num As Single, i As Single, cols As Single, row As Single
Dim sht_no As Single, form_name_len As Single, cell_string As Variant, cell_name_len As Single, start As Single
Dim test_space As Single, sheet_name As String, test2 As Variant, test3 As Variant, second_quote As Variant, background_color As Single
Dim test_1 As Single, color_background(4), rows_to_scan As Single

status_switch = False   ' this puts progress in the status bar

color_background(1) = 0
color_background(2) = 1
color_background(3) = 15
color_background(4) = 16

'
' Define the current sheet and the number of sheets
'
current_sheet = ActiveSheet.Name
this_sheet = ActiveSheet.Index

num_sheets = Sheets.Count

current_calc = application.calculation

Application.Calculation = xlCalculationManual


x_find_rows      ' run programs to find the number of rows
x_find_cols
 
rows_to_scan = max_row
cols_to_scan = max_col

cell_range = ActiveCell.Address

' Range(cell_range).Select
'
'    With Selection.Interior
'        .PatternColorIndex = xlAutomatic
'          background_color = xlAutomatic
'    End With

On Error Resume Next
background = background_color
Application.DisplayAlerts = False

'
'  First Find the color of each sheet
'
total_sheets = False
single_sheet = True

'
'  Work through sheets depending on the input from the userfom in the option boxes
'

If total_sheets = True Then
  start_num = 1
  end_num = num_sheets
End If

If single_sheet = True Then
  start_num = this_sheet
  end_num = this_sheet
End If

'
'  First find the color and name of each sheet in the workbook
'

For i = 1 To num_sheets
   On Error Resume Next
   Sheets(i).Select
   sheets_name(i) = Application.ActiveSheet.Name
   sheet_color(i) = Application.ActiveSheet.Tab.Color
    
    If status_switch = True Then Application.StatusBar = " Cycling through Sheets " & sheets_name(i) & " Sheet Colour " & sheet_color(i)
Next i

'
' Adjust Colors in Sheet or sheets for the paticular cell reference
'

 For sht_no = start_num To end_num

     Sheets(sht_no).Select
     sht_name = ActiveSheet.Name
'
'  Loop through cells in the current sheet
'
    tot_cells = 0
    cells_analyzed = 0

    For cols = 1 To cols_to_scan
      For row = 1 To rows_to_scan
        
'
'  Get the cell string for each cell in the sheet
'
        cell_string = Cells(row, cols).Formula
        cell_string_original = Cells(row, cols).Formula
               
'
'  Sheet name is the cell string adjusted for one to the right
'
        On Error Resume Next
        sheet_name = Mid(cell_string, 1, Len(cell_string))
 '
 '  This tests for blanks and text and makes the program much faster
 '
       test_text = WorksheetFunction.IsText(cell_string)
     
       test_equal = 0
       test_1 = 0
             
       On Error GoTo skip_test:
        
       On Error Resume Next
       test_1 = WorksheetFunction.Find("=", cell_string)
  
       If (test_1 <> 0) Then test_equal = 1

       tot_cells = tot_cells + 1
    
skip_test:
                                  
    If status_switch = True Then Application.StatusBar = " Sheet Name:  " & sht_name & " Row Number " & row & " Colum Number " & cols & " Cell String " & cell_string & "Cells Read " & tot_cells & " Cells Analysed " & cells_analyzed
               
'
'  find the formula in each cell if the cell is non-blank
'
     If test_equal = 1 Then
           
        cells_analyzed = cells_analyzed + 1
           
        if_length = 0
        lookup_length = 0
        index_length = 0
        cell_name_len = 0
        
        On Error Resume Next
 '
 ' Find an exclamation mark for a different sheet
 '
        cell_name_len = WorksheetFunction.Find("!", cell_string)
 '
 ' This finds the sheet name when it is after the = sign
 '
 ' If it is not from another sheet, then the length is zero
 '
        If (cell_name_len <> 0) Then
            start = WorksheetFunction.Find("=", cell_string)
            sheet_name = Mid(cell_string, start + 1, cell_name_len - start - 1)
            cell_string = sheet_name
        End If
 '
 '  Test for sheet name in a formula
 '
       form_name_len = 0
       
       On Error Resume Next
             form_name_len = WorksheetFunction.Find("*", cell_string)
       On Error Resume Next
             form_name_len = WorksheetFunction.Find("/", cell_string)
       On Error Resume Next
             form_name_len = WorksheetFunction.Find("+", cell_string)
       On Error Resume Next
             form_name_len = WorksheetFunction.Find("-", cell_string)
        On Error Resume Next
             form_name_len = WorksheetFunction.Find("(", cell_string)
             
'
' Find the sheet name from the formula symbol
'
       If (form_name_len <> 0) Then
            sheet_name = Mid(cell_string, form_name_len + 1, cell_name_len - form_name_len - 1)
            Cells(row, cols).Select
        End If
             
 '
 '  Find sheet names in LOOKUP formulas with different sheet name
 '
        if_switch = 0
        lookup_switch = 0
        index_switch = 0
        transpose_switch = 0
        match_switch = 0

        match_length = 0
        index_length = 0
        transpose_length = 0
        lookup_length = 0

        total_length = 0

        On Error Resume Next
        if_length = WorksheetFunction.Find("IF", cell_string_original)

        If if_length <> 0 Then if_switch = 1

        On Error Resume Next
        lookup_length = WorksheetFunction.Find("LOOKUP", cell_string_original)
        
        If lookup_length <> 0 Then lookup_switch = 1
        
        On Error Resume Next
        index_length = WorksheetFunction.Find("INDEX", cell_string)
        
        If index_length <> 0 Then index_switch = 1
        
        On Error Resume Next
        transpose_length = WorksheetFunction.Find("TRANSPOSE", cell_string)
        
        If transpose_length <> 0 Then transpose_switch = 1
        
        On Error Resume Next
        match_length = WorksheetFunction.Find("MATCH", cell_string)
        
         If match_length <> 0 Then match_switch = 1

        total_length = if_length + lookup_length + index_length + transpose_length + match_length
        
        If total_length <> 0 Then
 '
 '  Different Start Points if no space in sheet name
 '
           start = 1
           
           If lookup_switch = 1 Or match_switch = 1 Then
           On Error Resume Next
           start = WorksheetFunction.Find(",", cell_string_original) - 0
           End If
        
           If index_switch = 1 Or transpose_switch = 1 Or if_switch = 1 Then
           On Error Resume Next
           start = WorksheetFunction.Find("(", cell_string_original) - 0
           End If
        
'
' If there are spaces in the sheet it is easier
'
           
           On Error Resume Next
           start = WorksheetFunction.Find("'", cell_string_original) - 1
           
           On Error Resume Next
           cell_name_len = WorksheetFunction.Find("!", cell_string_original)
                                 
           On Error Resume Next
           sheet_name = Mid(cell_string_original, start + 1, cell_name_len - start - 1)
           
          If status_switch = truen Then Application.StatusBar = " Function Found - Sheet Name   " & sheet_name & "      Start Column ! " & start & "     Colum Number " & cols & "     Cell String " & cell_string_original
          
          cell_string = sheet_name
          cell_name_len = total_length
                       
        End If
 
'
' Find if the sheet name has a space
'
        test_space = 0
        On Error Resume Next
'
' Find the number of the space
'
        test_space = WorksheetFunction.Find(" ", cell_string)
            
'        MsgBox " Cell String  " & cell_string & " test_space " & test_space
            
        If test_space > 0 Then
             
         first_quote = WorksheetFunction.Find("'", cell_string)
         test2 = WorksheetFunction.Replace(cell_string, first_quote, 1, "")
                
         second_quote = WorksheetFunction.Find("'", test2)
         test3 = WorksheetFunction.Replace(test2, second_quote, 1, "")
        
         cell_string = test3
                  
         sheet_name = cell_string
               
          If status_switch = True Then Application.StatusBar = " Found Input from  " & sheet_name & " Row Number " & row & " Colum Number " & cols & " Sheet Name " & sheet_name & "test 2 " & test2 & "test 3 " & test3
                               
        End If
       
       If (cell_name_len <> 0) Then
            For i = 1 To num_sheets
                              
                If (sheet_name = sheets_name(i)) Then
                    Cells(row, cols).Font.Color = sheet_color(i)
 '                   Cells(row, cols).Interior.Color = background
                End If   ' End of blank test
            Next i
       End If
       
     End If ' Test on whether the cell is blank
                                        
     Next row
 Next cols

 If status_switch = True Then Application.StatusBar = " Finished Analysing " & sht_no

 Next sht_no

Sheets(current_sheet).Select

Application.Calculation = current_calc

Application.StatusBar = False

Erase sheets_name
Erase sheet_color

range("A1").select

End Sub




Sub x_hide_sheets_after()

num_sheet = ActiveSheet.Index

MsgBox num_sheet


For sheet_num = num_sheet + 1 To Sheets.Count

Sheets(sheet_num).Visible = False

Next sheet_num

For sheet_num = 1 To num_sheet - 1

Sheets(sheet_num).Visible = False

Next sheet_num

End Sub


Sub x_Put_Sheet_Names_in_A1()
'
'  This is the part of ths sheet that puts in the hyperlinks
'

Dim test As Single

'test = MsgBox(" This Macro puts the Sheet Name in cell A1 of each sheet " & _
'         chr(13) & " It will not overwrite cells that are not blank " & _
'         chr(13) & " Do you want to continue", vbOKCancel)
 
 If test = 2 Then Exit Sub

Dim sht_name(1500)
Dim i As Single
Dim num As Single
Dim home As String
Dim sheet_name As String


sheet_name = ActiveSheet.Name

num = Sheets.Count

On Error Resume Next
Sheets(1).Select
For i = 1 To num
   Sheets(i).Select
   sht_name(i) = ActiveSheet.Name
   
   If i = 1 Then
     home = "'" & sht_name(i) & "'!A1"
   End If
   
   Range("A1").Select
   Range("A1").Activate
   
   If i > 1 Then
     If (Range("A1")) = "" Then
      On Error Resume Next
      Range("A1") = sht_name(i)
     End If
   End If

   If (i > 1) Then
   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        home, TextToDisplay:=sheet_name

   End If
'   MsgBox (sht_name(i) & num & " " & i)
    If (i < num) Then ActiveSheet.Next.Select
Next i

Sheets(sheet_name).Select

End Sub



